Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/SYSMAP.FRM

Text File | 1996-05-02 | 5KB | 193 lines

VERSION 4.00
Begin VB.Form SysMapForm
   Caption         =   "SysMap"
   ClientHeight    =   3495
   ClientLeft      =   1500
   ClientTop       =   1260
   ClientWidth     =   6270
   Height          =   4185
   Left            =   1440
   LinkTopic       =   "Form1"
   ScaleHeight     =   3495
   ScaleWidth      =   6270
   Top             =   630
   Width           =   6390
   Begin VB.TextBox EntryText
      BeginProperty Font
         name            =   "Courier New"
         charset         =   1
         weight          =   400
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   3495
      Left            =   3480
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Text            =   "SYSMAP.frx":0000
      Top             =   0
      Width           =   2775
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   3495
      Left            =   0
      ScaleHeight     =   229
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   221
      TabIndex        =   0
      Top             =   0
      Width           =   3375
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   3240
      Top             =   3120
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "SysMapForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' ***********************************************
' Display a list of the colors in the logical
' palette and how they map to the system palette.
' ***********************************************
Sub ShowEntries()
Dim num_entries As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim pixel As Byte
Dim num As Long
Dim orig_color As Long
Dim i As Integer
Dim txt As String
Dim istr As String
Dim pixelstr As String
Dim rstr As String
Dim gstr As String
Dim bstr As String

    If Pict.Picture = 0 Then
        EntryText.Text = "No picture loaded."
        Exit Sub
    ElseIf Pict.Picture.hPal = 0 Then
        EntryText.Text = "Default palette."
        Exit Sub
    End If

    num_entries = GetPaletteEntries(Pict.Picture.hPal, 0, 256, palentry(0))

    ' Save the color of pixel (0, 0).
    orig_color = Pict.Point(0, 0)

    txt = "Log Sys  Red Green Blue" & vbCrLf
    For i = 0 To num_entries - 1
        ' See to what system entry each logical
        ' palette entry is mapped.
        Pict.PSet (0, 0), i + &H1000000

        num = GetBitmapBits(Pict.Image, 1, pixel)

        ' Add the information to the string.
        istr = Format$(i)
        pixelstr = Format$(pixel)
        rstr = Format$(palentry(i).peRed)
        gstr = Format$(palentry(i).peGreen)
        bstr = Format$(palentry(i).peBlue)
        txt = txt & _
            Space$(3 - Len(istr)) & istr & _
            Space$(4 - Len(pixelstr)) & pixelstr & _
            Space$(5 - Len(rstr)) & rstr & _
            Space$(6 - Len(gstr)) & gstr & _
            Space$(5 - Len(bstr)) & bstr & vbCrLf
    Next i

    ' Restore pixel (0, 0) to its original color.
    Pict.PSet (0, 0), orig_color

    EntryText.Text = txt
End Sub

Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hDC, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If

    ShowEntries
End Sub



Private Sub Form_Resize()
Dim wid As Single

    EntryText.Move ScaleWidth - EntryText.Width, _
        0, EntryText.Width, ScaleHeight

    wid = EntryText.Left - 20
    If wid < 100 Then wid = 100
    Pict.Move 0, 0, wid, ScaleHeight
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

Private Sub mnuFileLoad_Click()
Dim fname As String

    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)

    ' Load the picture.
    Pict.Picture = LoadPicture(fname)

    ' Update the list of colors.
    ShowEntries
End Sub